home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / EDWIN / COMFUN.S < prev    next >
Encoding:
Text File  |  1993-08-28  |  3.6 KB  |  115 lines
  1. ;;;
  2. ;;;    Copyright (c) 1985 Massachusetts Institute of Technology
  3. ;;;
  4. ;;;    This material was developed by the Scheme project at the
  5. ;;;    Massachusetts Institute of Technology, Department of
  6. ;;;    Electrical Engineering and Computer Science.  Permission to
  7. ;;;    copy this software, to redistribute it, and to use it for any
  8. ;;;    purpose is granted, subject to the following restrictions and
  9. ;;;    understandings.
  10. ;;;
  11. ;;;    1. Any copy made of this software must include this copyright
  12. ;;;    notice in full.
  13. ;;;
  14. ;;;    2. Users of this software agree to make their best efforts (a)
  15. ;;;    to return to the MIT Scheme project any improvements or
  16. ;;;    extensions that they make, so that these may be included in
  17. ;;;    future releases; and (b) to inform MIT of noteworthy uses of
  18. ;;;    this software.
  19. ;;;
  20. ;;;    3.  All materials developed as a consequence of the use of
  21. ;;;    this software shall duly acknowledge such use, in accordance
  22. ;;;    with the usual standards of acknowledging credit in academic
  23. ;;;    research.
  24. ;;;
  25. ;;;    4. MIT has made no warrantee or representation that the
  26. ;;;    operation of this software will be error-free, and MIT is
  27. ;;;    under no obligation to provide any services, by way of
  28. ;;;    maintenance, update, or otherwise.
  29. ;;;
  30. ;;;    5.  In conjunction with products arising from the use of this
  31. ;;;    material, there shall be no use of the name of the
  32. ;;;    Massachusetts Institute of Technology nor of any adaptation
  33. ;;;    thereof in any advertising, promotional, or sales literature
  34. ;;;    without prior written consent from MIT in each case.
  35. ;;;
  36. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  37. ;;;
  38. ;;;     Modified by Texas Instruments Inc 8/15/85
  39. ;;;
  40. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  41.  
  42. ;;; sum global definitions
  43.  
  44.  
  45. (define integer-divide
  46.    (lambda (a b)
  47.       (cons (quotient a b) (remainder a b))))
  48.  
  49. (define integer-divide-quotient car)
  50.  
  51. (define integer-divide-remainder cdr)
  52.  
  53. (define char->name
  54.   (lambda (char)
  55.     (define (%char->name char)
  56.       (let ((i (char->integer char)))
  57.         (cond ((zero? i) "")
  58.               ((= i 27) "Meta-")
  59.               ((and (>= i 1) (<= i 31))
  60.                (string-append "Ctrl-" (char->name (integer->char (+ i 64)))))
  61.               (else (list->string (list char))))))
  62.     (if (atom? char)
  63.         (%char->name char)
  64.         (string-append (%char->name (car char))
  65.                        (%char->name (cadr char))))))
  66. (define string-append-separated
  67.   (lambda (s1 s2)
  68.     (cond ((zero? (string-length s1)) s2)
  69.           ((zero? (string-length s2)) s1)
  70.           (else (string-append s1 " " s2)))))
  71.  
  72. (define string-append-with-blanks
  73.   (lambda strings
  74.     ((rec loop
  75.        (lambda (strings)
  76.          (if (null? strings) ""
  77.              (string-append-separated (car strings) (loop (cdr strings))))))
  78.      strings)))
  79.  
  80. (define char->string
  81.   (lambda (char)
  82.     (if (char? char)
  83.         (char->name char)
  84.     (error "Bad argument to char->string" char))))
  85.  
  86. (define list->string*
  87.   (lambda (l)
  88.     (if (pair? l)
  89.     (string-append "("
  90.                (apply string-append-with-blanks
  91.                   (mapcar obj->string l))
  92.                ")")
  93.     (error "Bad argument to list->string*" l))))
  94.  
  95. (define obj->string
  96.   (lambda (obj)
  97.     (cond ((pair? obj) (list->string* obj))
  98.       ((char? obj) (char->string obj))
  99.       ((integer? obj) (number->string obj 10))
  100.       ((null? obj) "()")
  101.       (else (error "Bad argument to obj->string" obj)))))
  102.  
  103. (define char-base char->integer)
  104.  
  105. (define char->digit
  106.   (lambda (i radix)
  107.     (- i (char->integer #\0))))
  108.  
  109. (define identity-procedure (lambda (x) x))
  110.  
  111.  
  112.  
  113.  
  114.  
  115.